home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / tty-inspect.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  7.9 KB  |  239 lines
  1. ;;; -*- Log: code.log; Package: inspect -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: tty-inspect.lisp,v 1.10 91/05/22 15:44:08 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Tty interface for INSPECT.
  15. ;;;
  16. ;;; Written by Blaine Burks
  17.  
  18. ;;;
  19. (in-package "INSPECT")
  20.  
  21. ;;; The Tty inspector views LISP objects as being composed of parts.  A list,
  22. ;;; for example, would be divided into it's members, and a structure into its
  23. ;;; slots.  These parts are stored in a list.  The first two elements of this
  24. ;;; list are for bookkeeping.  The first element is a preamble string that will
  25. ;;; be displayed before the object.  The second element is a boolean value that
  26. ;;; indicates whether a label will be printed in front of a value, or just the
  27. ;;; value.  Symbols and structures need to display both a slot name and a
  28. ;;; value, while lists, vectors, and atoms need only display a value.  If the
  29. ;;; second member of a parts list is t, then the third and successive members
  30. ;;; must be an association list of slot names and values.  When the second slot
  31. ;;; is nil, the third and successive slots must be the parts of an object.
  32. ;;;
  33.  
  34. ;;; *tty-object-stack* is an assoc list of objects to their parts.  
  35. ;;;
  36. (defvar *tty-object-stack* ())
  37.  
  38. ;;; ### Copied from inspect.lisp.  Remove after it is up.
  39. (defparameter inspect-length 10)
  40. (defparameter inspect-level 1)
  41.  
  42. (proclaim '(inline numbered-parts-p))
  43. (defun numbered-parts-p (parts)
  44.   (second parts))
  45.  
  46. (defconstant parts-offset 2)
  47.  
  48. (defun nth-parts (parts n)
  49.   (if (numbered-parts-p parts)
  50.       (cdr (nth (+ n parts-offset) parts))
  51.       (nth (+ n parts-offset) parts)))
  52.  
  53. ;;; Dummy definition for when we have no CLX...
  54. (defun inspect (object)
  55.   (tty-inspect object))
  56.  
  57. (defun tty-inspect (object)
  58.   (unwind-protect
  59.       (input-loop object (describe-parts object) *standard-output*)
  60.     (setf *tty-object-stack* nil)))
  61.  
  62. ;;; When %illegal-object% occurs in a parts list, it indicates that that slot
  63. ;;; is unbound.
  64. (defvar %illegal-object% (cons nil nil))
  65.  
  66. (defun input-loop (object parts s)
  67.   (tty-display-object parts s)
  68.   (loop
  69.     (format s "~&> ")
  70.     (force-output)
  71.     (let ((command (read))
  72.       ;; Use 2 less than length because first 2 elements are bookkeeping.
  73.       (parts-len-2 (- (length parts) 2)))
  74.       (typecase command
  75.     (integer
  76.      (cond ((< -1 command parts-len-2)
  77.         (cond ((eq (nth-parts parts command) %illegal-object%)
  78.                (format s "~%That slot is unbound.~%"))
  79.               (t
  80.                (push (cons object parts) *tty-object-stack*)
  81.                (setf object (nth-parts parts command))
  82.                (setf parts (describe-parts object))
  83.                (tty-display-object parts s))))
  84.            (t
  85.         (if (= parts-len-2 0)
  86.             (format s "~%This object contains nothing to inspect.~%~%")
  87.             (format s "~%Enter a VALID number (~:[0-~D~;0~]).~%~%"
  88.                 (= parts-len-2 1) (1- parts-len-2))))))
  89.     (symbol
  90.      (case (find-symbol (symbol-name command) (find-package "KEYWORD"))
  91.        ((:q :e)
  92.         (return object))
  93.        (:u
  94.         (cond (*tty-object-stack*
  95.            (setf object (caar *tty-object-stack*))
  96.            (setf parts (cdar *tty-object-stack*))
  97.            (pop *tty-object-stack*)
  98.            (tty-display-object parts s))
  99.           (t (format s "~%Bottom of Stack.~%"))))
  100.        (:r
  101.         (setf parts (describe-parts object))
  102.         (tty-display-object parts s))
  103.        (:d
  104.         (tty-display-object parts s))
  105.        ((:h :? :help)
  106.         (show-help s))
  107.        (t
  108.         (do-tty-inspect-eval command s))))
  109.     (t
  110.      (do-tty-inspect-eval command s))))))
  111.  
  112. (defun do-tty-inspect-eval (command stream)
  113.   (let ((result-list (restart-case (multiple-value-list (eval command))
  114.                (nil () :report "Return to the TTY-INSPECTOR"
  115.               (format stream "~%Returning to INPSECTOR.~%")
  116.               (return-from do-tty-inspect-eval nil)))))
  117.     (setf /// // // / / result-list)
  118.     (setf +++ ++ ++ + + - - command)
  119.     (setf *** ** ** * * (car /))
  120.     (format stream "~&~{~S~%~}" /)))
  121.  
  122. (defun show-help (s)
  123.   (terpri)
  124.   (write-line "TTY-Inspector Help:" s)
  125.   (write-line "  R           -  recompute current object." s)
  126.   (write-line "  D           -  redisplay current object." s)
  127.   (write-line "  U           -  Move upward through the object stack." s)
  128.   (write-line "  Q, E        -  Quit TTY-INSPECTOR." s)
  129.   (write-line "  ?, H, Help  -  Show this help." s))
  130.  
  131. (defun tty-display-object (parts stream)
  132.   (format stream "~%~a" (car parts))
  133.   (let ((numbered-parts-p (numbered-parts-p parts))
  134.     (parts (cddr parts)))
  135.     (do ((part parts (cdr part))
  136.      (i 0 (1+ i)))
  137.     ((endp part) nil)
  138.       (if numbered-parts-p
  139.       (format stream "~d. ~a: ~a~%" i (caar part)
  140.           (if (eq (cdar part) %illegal-object%)
  141.               "Unbound"
  142.               (cdar part)))
  143.       (format stream "~d. ~a~%" i (car part))))))
  144.  
  145.  
  146.  
  147. ;;;; DESCRIBE-PARTS
  148.  
  149. (defun describe-parts (object)
  150.   (typecase object
  151.     (symbol (describe-symbol-parts object))
  152.     (structure (describe-structure-parts object))
  153.     (function (describe-function-parts object))
  154.     (vector (describe-vector-parts object))
  155.     (array (describe-array-parts object))
  156.     (cons (describe-cons-parts object))
  157.     (t (describe-atomic-parts object))))
  158.  
  159. (defun describe-symbol-parts (object)
  160.   (list (format nil "~s is a symbol.~%" object) t
  161.     (cons "Value" (if (boundp object)
  162.               (symbol-value object)
  163.               %illegal-object%))
  164.     (cons "Function" (if (fboundp object)
  165.                  (symbol-function object)
  166.                  %illegal-object%))
  167.     (cons "Plist" (symbol-plist object))
  168.     (cons "Package" (symbol-package object))))
  169.  
  170. (defun describe-structure-parts (object)
  171.   (let ((dd-slots
  172.      (c::dd-slots
  173.       (ext:info type defined-structure-info (type-of object))))
  174.     (parts-list ()))
  175.     (push (format nil "~s is a structure.~%" object) parts-list)
  176.     (push t parts-list)
  177.     (dolist (dd-slot dd-slots (nreverse parts-list))
  178.       (push (cons (c::dsd-%name dd-slot)
  179.           (funcall (c::dsd-accessor dd-slot) object))
  180.         parts-list))))
  181.  
  182. (defun describe-function-parts (object)
  183.   (let* ((type (kernel:get-type object))
  184.      (object (if (= type vm:closure-header-type)
  185.              (kernel:%closure-function object)
  186.              object)))
  187.     (list (format nil "Function ~s.~@[~%Argument List: ~a~]." object
  188.           (kernel:%function-header-arglist object)
  189.           ;; Defined from stuff used to be here.  Someone took it out.
  190.           )
  191.       t)))
  192.  
  193. (defun describe-vector-parts (object)
  194.   (list* (format nil "Object is a ~:[~;displaced ~]vector of length ~d.~%"
  195.          (and (lisp::array-header-p object)
  196.               (lisp::%array-displaced-p object))
  197.          (length object))
  198.      nil
  199.      (coerce object 'list)))
  200.  
  201. (defun describe-cons-parts (object)
  202.   (list* (format nil "Object is a LIST of length ~d.~%" (length object))
  203.      nil
  204.      object))
  205.  
  206. ;;; ### Copied from inspect.lisp.  Remove when it is up.
  207. ;;; 
  208. (defun index-string (index rev-dimensions)
  209.   (if (null rev-dimensions)
  210.       "[]"
  211.       (let ((list nil))
  212.     (dolist (dim rev-dimensions)
  213.       (multiple-value-bind (q r)
  214.                    (floor index dim)
  215.         (setq index q)
  216.         (push r list)))
  217.     (format nil "[~D~{,~D~}]" (car list) (cdr list)))))
  218.  
  219. (defun describe-array-parts (object)
  220.   (let* ((length (min (array-total-size object) inspect-length))
  221.      (reference-array (make-array length :displaced-to object))
  222.      (dimensions (array-dimensions object))
  223.      (parts ()))
  224.     (push (format nil "Object is ~:[a displaced~;an~] array of ~a.~%~
  225.                        Its dimensions are ~s.~%"
  226.           (array-element-type object)
  227.           (and (lisp::array-header-p object)
  228.                (lisp::%array-displaced-p object))
  229.           dimensions)
  230.       parts)
  231.     (push t parts)
  232.     (dotimes (i length (nreverse parts))
  233.       (push (cons (format nil "~a " (index-string i (reverse dimensions)))
  234.           (aref reference-array i))
  235.         parts))))
  236.  
  237. (defun describe-atomic-parts (object)
  238.   (list (format nil "Object is an atom.~%") nil object))
  239.